home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / copascal.arc / BLOCKB.MOD < prev    next >
Encoding:
Text File  |  1979-12-31  |  10.6 KB  |  297 lines
  1.  
  2. (*---------------------------------------------------EXPRESSION-----*)
  3.  
  4.       procedure EXPRESSION (* FSYS: SYMSET; var X: ITEM *) ;
  5.       (*
  6.          Note: dynamic variables for Y have been used due to the
  7.                constraints imposed upon local variables in recursion.
  8.       *)
  9.  
  10.       type ITEMptr = ^ITEM;   (* static > dynamic : SCHOENING *)
  11.       var Y  : ITEMptr;
  12.           OP : SYMBOL;
  13.  
  14.         procedure SIMPLEEXPRESSION( FSYS : SYMSET; var X : ITEM );
  15.         var Y  : ITEMptr;
  16.             OP : SYMBOL;
  17.  
  18.           procedure TERM( FSYS : SYMSET; var X : ITEM );
  19.           var Y  : ITEMptr;
  20.               OP : SYMBOL;
  21.               TS : TYPSET;
  22.  
  23.             procedure FACTOR( FSYS : SYMSET; var X : ITEM );
  24.             var I, F : INTEGER;
  25.  
  26.               procedure STANDFCT( N : INTEGER );
  27.               var TS: TYPSET;
  28.               begin (*STANDARD FUNCTION NO. N*)
  29.                 if SY = LPARENT then INSYMBOL else ERROR(9);
  30.                 if ( N < 17 ) OR ( N=19 ) then begin
  31.                   EXPRESSION( FSYS+[RPARENT], X );
  32.                   case N of
  33.  
  34. { ABS, SQR }    0,2: begin
  35.                        TS := [INTS,REALS];
  36.                        TAB[I].TYP := X.TYP;
  37.                        if X.TYP = REALS then N := N+1
  38.                      end;
  39.  
  40. { ODD, CHR    } 4,5: TS := [INTS];
  41.  
  42. { ORD         } 6  : TS := [INTS,BOOLS,CHARS];
  43.  
  44. { SUCC,  PRED } 7,8: begin
  45.                        TS := [INTS,BOOLS,CHARS];
  46.                        TAB[I].TYP := X.TYP
  47.                      end;
  48.  
  49. { ROUND,TRUNC } 9,10,11,12,13,14,15,16:
  50. { SIN,COS,... }      begin
  51.                        TS := [INTS,REALS];
  52.                        if X.TYP = INTS then EMIT1(26,0)
  53.                      end;
  54.  
  55. { RANDOM      } 19:  begin
  56.                        TS := [INTS];
  57.                        TAB[I].TYP := X.TYP;
  58.                      end;
  59.                   end; (* case *)
  60.                   if X.TYP in TS then EMIT1(8,N) else
  61.                   if X.TYP <> NOTYP then ERROR(48);
  62.  
  63.                 end else begin (* N in [17,18] *)
  64. { EOF, EOLN   }   if SY <> IDENT then ERROR(2) else
  65.                   if ID <> 'INPUT     ' then ERROR(0) else INSYMBOL;
  66.                   EMIT1(8,N);
  67.                 end;
  68.                 X.TYP := TAB[I].TYP;
  69.                 if SY = RPARENT then INSYMBOL else ERROR(4)
  70.               end; (* STANDFCT *)
  71.  
  72.             begin (* FACTOR *)
  73.               X.TYP := NOTYP;
  74.               X.REF := 0;
  75.               TEST(FACBEGSYS, FSYS, 58);
  76.               while SY in FACBEGSYS do begin
  77. {   ID   }      if SY = IDENT then begin
  78.                   I := LOC(ID);
  79.                   INSYMBOL;
  80.                   WITH TAB[I] do case OBJ of
  81.  
  82.               KONSTANT: begin
  83.                           X.TYP := TYP;
  84.                           X.REF := 0;
  85.                           if X.TYP = REALS then EMIT1(25,ADR)
  86.                             else EMIT1(24,ADR)
  87.                         end;
  88.  
  89.               VARIABLE: begin
  90.                           X.TYP := TYP;
  91.                           X.REF := REF;
  92.                           if SY in [LBRACK,LPARENT,PERIOD] then begin
  93.                             if NORMAL then F := 0 else F := 1;
  94.                               EMIT2(F, LEV, ADR);
  95.                               SELECTOR(FSYS,X);
  96.                               if X.TYP in STANTYPS then EMIT(34)
  97.                             end else begin
  98.                               if X.TYP in STANTYPS then
  99.                                 if NORMAL then F := 1 else F := 2
  100.                               else
  101.                                 if NORMAL then F := 0 else F := 1;
  102.                               EMIT2(F, LEV, ADR)
  103.                             end;
  104.                         end;
  105.  
  106.               TYPE1, PROZEDURE:    ERROR(44);
  107.  
  108.               FUNKTION : begin
  109.                            X.TYP := TYP;
  110.                            if LEV <> 0 then CALL(FSYS, I) else STANDFCT(ADR);
  111.                          end
  112.  
  113.                     end (*CASE,WITH*)
  114.                   end else
  115.                   if SY in [CHARCON,INTCON,REALCON] then begin
  116.                      if SY = REALCON then begin
  117.                        X.TYP := REALS;
  118.                        ENTERREAL(RNUM);
  119.                        EMIT1(25, C1)
  120.                      end else
  121.                      begin
  122.                        if SY = CHARCON then X.TYP := CHARS
  123.                                        else X.TYP := INTS;
  124.                        EMIT1(24, INUM)
  125.                      end;
  126.                      X.REF := 0; INSYMBOL
  127.                    end else
  128. {   (   }          if SY = LPARENT then begin
  129.                      INSYMBOL;
  130.                      EXPRESSION(FSYS+[RPARENT], X);
  131.                      if SY = RPARENT then INSYMBOL else ERROR(4);
  132.                    end else
  133. {  NOT  }          if SY = NOTSY then
  134.                    begin
  135.                      INSYMBOL;
  136.                      FACTOR(FSYS,X);
  137.                      if X.TYP=BOOLS then EMIT(35) else
  138.                        if X.TYP<>NOTYP then ERROR(32)
  139.                    end;
  140.                   TEST(FSYS, FACBEGSYS, 6)
  141.                 end (*while*)
  142.             end; (*FACTOR*)
  143.  
  144.           begin (*TERM*)
  145.             new( Y );
  146.             FACTOR(FSYS+[TIMES,RDIV,IDIV,IMOD,ANDSY], X);
  147.             while SY in [TIMES,RDIV,IDIV,IMOD,ANDSY] do begin
  148.                 OP := SY;
  149.                 INSYMBOL;
  150.                 FACTOR(FSYS+[TIMES,RDIV,IDIV,IMOD,ANDSY], Y^ );
  151. {  *  }         if OP = TIMES then begin
  152.                   X.TYP := RESULTTYPE(X.TYP, Y^.TYP);
  153.                   case X.TYP of
  154.                     NOTYP: ;
  155.                     INTS : EMIT(57);
  156.                     REALS: EMIT(60);
  157.                   end
  158.                 end else
  159. {  /  }         if OP = RDIV then begin
  160.                   if X.TYP = INTS then begin
  161.                     EMIT1(26,1);
  162.                     X.TYP := REALS
  163.                   end;
  164.                   if Y^.TYP = INTS then begin
  165.                     EMIT1(26,0);
  166.                     Y^.TYP := REALS
  167.                   end;
  168.                   if (X.TYP=REALS) AND (Y^.TYP=REALS) then EMIT(61)
  169.                     else begin
  170.                       if (X.TYP<>NOTYP) AND (Y^.TYP<>NOTYP) then ERROR(33);
  171.                       X.TYP := NOTYP
  172.                     end
  173.                 end else
  174. { AND }         if OP = ANDSY then begin
  175.                   if (X.TYP=BOOLS) AND (Y^.TYP=BOOLS) then EMIT(56)
  176.                     else begin
  177.                       if (X.TYP<>NOTYP) AND (Y^.TYP<>NOTYP) then ERROR(32);
  178.                       X.TYP := NOTYP
  179.                     end
  180.                 end else
  181. { DIV,MOD }     begin (*OP in [IDIV,IMOD]*)
  182.                   if (X.TYP=INTS) AND (Y^.TYP=INTS) then
  183.                     if OP=IDIV then EMIT(58) else EMIT(59)
  184.                   else begin
  185.                     if (X.TYP<>NOTYP) AND (Y^.TYP<>NOTYP) then ERROR(34);
  186.                     X.TYP := NOTYP
  187.                   end
  188.                 end
  189.               end;
  190.             dispose( Y );
  191.           end (*TERM*) ;
  192.  
  193.         begin (*SIMPLEEXPRESSION*)
  194.           new( Y );
  195. { +, - }  if SY in [PLUS,MINUS] then begin
  196.             OP := SY;
  197.             INSYMBOL;
  198.             TERM(FSYS+[PLUS,MINUS], X);
  199.             if X.TYP > REALS then ERROR(33)
  200.               else if OP = MINUS then EMIT(36)
  201.           end else TERM( FSYS+[ PLUS,MINUS,ORSY ], X );
  202.           while SY in [PLUS,MINUS,ORSY] do begin
  203.             OP := SY;
  204.             INSYMBOL;
  205.             TERM(FSYS+[PLUS,MINUS,ORSY], Y^);
  206. { OR   }    if OP = ORSY then begin
  207.                  if (X.TYP=BOOLS) AND (Y^.TYP=BOOLS) then EMIT(51)
  208.                    else begin
  209.                      if (X.TYP<>NOTYP) AND (Y^.TYP<>NOTYP) then ERROR(32);
  210.                      X.TYP := NOTYP
  211.                    end
  212.                end else begin
  213.                  X.TYP := RESULTTYPE(X.TYP, Y^.TYP);
  214.                  case X.TYP of
  215.                    NOTYP: ;
  216.                    INTS : if OP = PLUS then EMIT(52) else EMIT(53);
  217.                    REALS: if OP = PLUS then EMIT(54) else EMIT(55);
  218.                  end;
  219.                end;
  220.             end;
  221.           dispose( Y );
  222.         end; (* SIMPLEEXPRESSION *)
  223.  
  224.       begin (*EXPRESSION*)
  225.         new( Y );
  226.         SIMPLEEXPRESSION(FSYS+[EQL,NEQ,LSS,LEQ,GTR,GEQ], X);
  227.         if SY in [EQL,NEQ,LSS,LEQ,GTR,GEQ] then begin
  228.           OP := SY;
  229.           INSYMBOL;
  230.           SIMPLEEXPRESSION(FSYS, Y^ );
  231.           if (X.TYP in [NOTYP,INTS,BOOLS,CHARS]) AND (X.TYP = Y^.TYP) then
  232.             case OP of
  233.               EQL : EMIT(45);
  234.               NEQ : EMIT(46);
  235.               LSS : EMIT(47);
  236.               LEQ : EMIT(48);
  237.               GTR : EMIT(49);
  238.               GEQ : EMIT(50);
  239.             end else begin
  240.               if X.TYP = INTS then begin
  241.                 X.TYP := REALS;
  242.                 EMIT1(26,1)
  243.               end else if Y^.TYP = INTS then begin
  244.                 Y^.TYP := REALS;
  245.                 EMIT1(26,0);
  246.               end;
  247.               if (X.TYP=REALS) AND (Y^.TYP=REALS) then case OP of
  248.                 EQL : EMIT(39);
  249.                 NEQ : EMIT(40);
  250.                 LSS : EMIT(41);
  251.                 LEQ : EMIT(42);
  252.                 GTR : EMIT(43);
  253.                 GEQ : EMIT(44);
  254.               end else ERROR(35);
  255.             end;
  256.             X.TYP := BOOLS;
  257.           end;
  258.         dispose( Y );
  259.       end (*EXPRESSION*) ;
  260.  
  261.       procedure ASSIGNMENT(LV,AD: INTEGER);
  262.       var X,Y: ITEM; F: INTEGER;
  263.       (* TAB[I].OBJ in [VARIABLE,PROZEDURE] *)
  264.       begin
  265.         X.TYP := TAB[I].TYP;
  266.         X.REF := TAB[I].REF;
  267.         if TAB[I].NORMAL then F := 0 else F := 1;
  268.         EMIT2(F, LV, AD);
  269.         if SY in [LBRACK,LPARENT,PERIOD] then SELECTOR([BECOMES,EQL]+FSYS, X);
  270.         if SY = BECOMES then INSYMBOL else begin
  271.           ERROR(51);
  272.           if SY = EQL then INSYMBOL
  273.         end;
  274.         EXPRESSION(FSYS, Y);
  275.         if X.TYP = Y.TYP then
  276.           if X.TYP in STANTYPS then EMIT(38) else
  277.           if X.REF <> Y.REF then ERROR(46) else
  278.           if X.TYP = ARRAYS then EMIT1(23, ATAB[X.REF].SIZE)
  279.                             else EMIT1(23, BTAB[X.REF].VSIZE)
  280.         else
  281.         if (X.TYP=REALS) AND (Y.TYP=INTS) then begin
  282.           EMIT1(26,0); EMIT(38)
  283.         end else
  284.           if (X.TYP<>NOTYP) AND (Y.TYP<>NOTYP) then ERROR(46)
  285.       end; { ASSIGNMENT }
  286.  
  287.       procedure COMPOUNDSTMNT;
  288.       begin
  289.         INSYMBOL;
  290.         STATEMENT([SEMICOLON,endSY]+FSYS);
  291.         while SY in [SEMICOLON]+STATBEGSYS do begin
  292.           if SY = SEMICOLON then INSYMBOL else ERROR(14);
  293.           STATEMENT([SEMICOLON,endSY]+FSYS)
  294.         end;
  295.         if SY = EndSy then InSymbol else ERROR(57)
  296.       end; { CompuundStatement }
  297.